home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / prim / mode-motion.el.z / mode-motion.el
Encoding:
Text File  |  1998-05-21  |  5.2 KB  |  130 lines
  1. ;; Mode-specific mouse-highlighting of text.
  2. ;; Copyright (C) 1992, 1993 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of XEmacs.
  5.  
  6. ;; XEmacs is free software; you can redistribute it and/or modify it
  7. ;; under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 2, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; XEmacs is distributed in the hope that it will be useful, but
  12. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14. ;; General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  18. ;; Free Software Foundation, 59 Temple Place - Suite 330,
  19. ;; Boston, MA 02111-1307, USA.
  20.  
  21. ;;; Synched up with: Not in FSF.
  22.  
  23. (defvar mode-motion-hook nil
  24.   "Function or functions which are called whenever the mouse moves.
  25. You should normally use this rather than `mouse-motion-handler', which 
  26. does some additional window-system-dependent things.  This hook is local
  27. to every buffer, and should normally be set up by major-modes which want
  28. to use special highlighting.  Every time the mouse moves over a window,
  29. the mode-motion-hook of the buffer of that window is run.")
  30.  
  31. (make-variable-buffer-local 'mode-motion-hook)
  32.  
  33. (defvar mode-motion-extent nil)
  34. (make-variable-buffer-local 'mode-motion-extent)
  35.  
  36. (defvar mode-motion-help-echo-string nil
  37.   "String to be added as the 'help-echo property of the mode-motion extent.
  38. In order for this to work, you need to add the hook function
  39. `mode-motion-add-help-echo' to the mode-motion hook.  If this is a function,
  40. it will be called with one argument (the event) and should return a string
  41. to be added.  This variable is local to every buffer.")
  42. (make-variable-buffer-local 'mode-motion-help-echo-string)
  43.  
  44. (defun mode-motion-ensure-extent-ok (event)
  45.   (let ((buffer (event-buffer event)))
  46.     (if (and (extent-live-p mode-motion-extent)
  47.          (eq buffer (extent-object mode-motion-extent)))
  48.     nil
  49.       (setq mode-motion-extent (make-extent nil nil buffer))
  50.       (set-extent-property mode-motion-extent 'mouse-face 'highlight))))
  51.  
  52. (defun mode-motion-highlight-internal (event backward forward)
  53.   (let* ((buffer (event-buffer event))
  54.      (point (and buffer (event-point event))))
  55.     (if (and buffer
  56.          (not (eq buffer mouse-grabbed-buffer)))
  57.     ;; #### ack!! Too many calls to save-window-excursion /
  58.     ;; save-excursion (x-track-pointer calls, so does
  59.     ;; minibuf-mouse-tracker ...) This needs to be looked
  60.     ;; into.  It's complicated by the fact that sometimes
  61.     ;; a mode-motion-hook might really want to change
  62.     ;; the point.
  63.     ;;
  64.     ;; #### The save-excursion must come before the
  65.     ;; save-window-excursion in order to function properly.  I
  66.     ;; haven't given this much thought.  Is it a bug that this
  67.     ;; ordering is necessary or is it correct behavior?
  68.     (save-excursion
  69.       (save-window-excursion
  70.         (set-buffer buffer)
  71.         (mode-motion-ensure-extent-ok event)
  72.         (if point
  73.         (progn
  74.           (goto-char point)
  75.           (condition-case nil (funcall backward) (error nil))
  76.           (setq point (point))
  77.           (condition-case nil (funcall forward) (error nil))
  78.           (if (eq point (point))
  79.               (detach-extent mode-motion-extent)
  80.             (set-extent-endpoints mode-motion-extent point (point))))
  81.           ;; not over text; zero the extent.
  82.           (detach-extent mode-motion-extent)))))))
  83.  
  84. (defun mode-motion-highlight-line (event)
  85.   "For use as the value of `mode-motion-hook' -- highlight line under mouse."
  86.   (mode-motion-highlight-internal event 'beginning-of-line 'end-of-line))
  87.  
  88. (defun mode-motion-highlight-word (event)
  89.   "For use as the value of `mode-motion-hook' -- highlight word under mouse."
  90.   (mode-motion-highlight-internal
  91.    event
  92.    #'(lambda () (default-mouse-track-beginning-of-word nil))
  93.    #'(lambda () (default-mouse-track-end-of-word nil))))
  94.  
  95. (defun mode-motion-highlight-symbol (event)
  96.   "For use as the value of `mode-motion-hook' -- highlight symbol under mouse."
  97.   (mode-motion-highlight-internal
  98.    event
  99.    #'(lambda () (default-mouse-track-beginning-of-word t))
  100.    #'(lambda () (default-mouse-track-end-of-word t))))
  101.  
  102. (defun mode-motion-highlight-sexp (event)
  103.   "For use as the value of `mode-motion-hook' -- highlight form under mouse."
  104.   (mode-motion-highlight-internal
  105.    event
  106.    #'(lambda ()
  107.        (if (= (char-syntax (following-char)) ?\()
  108.        nil
  109.      (goto-char (scan-sexps (point) -1))))
  110.    #'(lambda ()
  111.        (if (= (char-syntax (following-char)) ?\))
  112.        (forward-char 1))
  113.        (goto-char (scan-sexps (point) 1)))))
  114.  
  115. (defun mode-motion-add-help-echo (event)
  116.   "For use as the value of `mode-motion-hook' -- add a 'help-echo property.
  117. This causes the string in the 'help-echo property to be displayed when the
  118. mouse moves over the extent.  See `mode-motion-help-echo-string' for
  119. documentation on how to control the string that is added."
  120.   (mode-motion-ensure-extent-ok event)
  121.   (let ((string (cond ((null mode-motion-help-echo-string) nil)
  122.               ((stringp mode-motion-help-echo-string)
  123.                mode-motion-help-echo-string)
  124.               (t (funcall mode-motion-help-echo-string event)))))
  125.     (if (stringp string)
  126.     (set-extent-property mode-motion-extent 'help-echo string))))
  127.  
  128.  
  129. (provide 'mode-motion)
  130.